home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlispsrc.arc / XLBFUN.C next >
C/C++ Source or Header  |  1988-02-11  |  14KB  |  679 lines
  1. /* xlbfun.c - xlisp basic built-in functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL xlenv,xlfenv,xldenv,true;
  10. extern LVAL s_evalhook,s_applyhook;
  11. extern LVAL s_car,s_cdr,s_nth,s_get,s_svalue,s_splist,s_aref;
  12. extern LVAL s_lambda,s_macro;
  13. extern LVAL s_comma,s_comat;
  14. extern LVAL s_unbound;
  15. extern char gsprefix[];
  16. extern int gsnumber;
  17.  
  18. /* external routines */
  19. extern LVAL xlxeval();
  20.  
  21. /* forward declarations */
  22. FORWARD LVAL bquote1();
  23. FORWARD LVAL defun();
  24. FORWARD LVAL makesymbol();
  25.  
  26. /* xeval - the built-in function 'eval' */
  27. LVAL xeval()
  28. {
  29.     LVAL expr;
  30.  
  31.     /* get the expression to evaluate */
  32.     expr = xlgetarg();
  33.     xllastarg();
  34.  
  35.     /* evaluate the expression */
  36.     return (xleval(expr));
  37. }
  38.  
  39. /* xapply - the built-in function 'apply' */
  40. LVAL xapply()
  41. {
  42.     LVAL fun,arglist;
  43.  
  44.     /* get the function and argument list */
  45.     fun = xlgetarg();
  46.     arglist = xlgalist();
  47.     xllastarg();
  48.  
  49.     /* apply the function to the arguments */
  50.     return (xlapply(pushargs(fun,arglist)));
  51. }
  52.  
  53. /* xfuncall - the built-in function 'funcall' */
  54. LVAL xfuncall()
  55. {
  56.     LVAL *newfp;
  57.     int argc;
  58.     
  59.     /* build a new argument stack frame */
  60.     newfp = xlsp;
  61.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  62.     pusharg(xlgetarg());
  63.     pusharg(NIL); /* will be argc */
  64.  
  65.     /* push each argument */
  66.     for (argc = 0; moreargs(); ++argc)
  67.     pusharg(nextarg());
  68.  
  69.     /* establish the new stack frame */
  70.     newfp[2] = cvfixnum((FIXTYPE)argc);
  71.     xlfp = newfp;
  72.  
  73.     /* apply the function to the arguments */
  74.     return (xlapply(argc));
  75. }
  76.  
  77. /* xmacroexpand - expand a macro call repeatedly */
  78. LVAL xmacroexpand()
  79. {
  80.     LVAL form;
  81.     form = xlgetarg();
  82.     xllastarg();
  83.     return (xlexpandmacros(form));
  84. }
  85.  
  86. /* x1macroexpand - expand a macro call */
  87. LVAL x1macroexpand()
  88. {
  89.     LVAL form,fun,args;
  90.  
  91.     /* protect some pointers */
  92.     xlstkcheck(2);
  93.     xlsave(fun);
  94.     xlsave(args);
  95.  
  96.     /* get the form */
  97.     form = xlgetarg();
  98.     xllastarg();
  99.  
  100.     /* expand until the form isn't a macro call */
  101.     if (consp(form)) {
  102.     fun = car(form);        /* get the macro name */
  103.     args = cdr(form);        /* get the arguments */
  104.     if (symbolp(fun) && fboundp(fun)) {
  105.         fun = xlgetfunction(fun);    /* get the expansion function */
  106.         macroexpand(fun,args,&form);
  107.     }
  108.     }
  109.  
  110.     /* restore the stack and return the expansion */
  111.     xlpopn(2);
  112.     return (form);
  113. }
  114.  
  115. /* xatom - is this an atom? */
  116. LVAL xatom()
  117. {
  118.     LVAL arg;
  119.     arg = xlgetarg();
  120.     xllastarg();
  121.     return (atom(arg) ? true : NIL);
  122. }
  123.  
  124. /* xsymbolp - is this an symbol? */
  125. LVAL xsymbolp()
  126. {
  127.     LVAL arg;
  128.     arg = xlgetarg();
  129.     xllastarg();
  130.     return (arg == NIL || symbolp(arg) ? true : NIL);
  131. }
  132.  
  133. /* xnumberp - is this a number? */
  134. LVAL xnumberp()
  135. {
  136.     LVAL arg;
  137.     arg = xlgetarg();
  138.     xllastarg();
  139.     return (fixp(arg) || floatp(arg) ? true : NIL);
  140. }
  141.  
  142. /* xintegerp - is this an integer? */
  143. LVAL xintegerp()
  144. {
  145.     LVAL arg;
  146.     arg = xlgetarg();
  147.     xllastarg();
  148.     return (fixp(arg) ? true : NIL);
  149. }
  150.  
  151. /* xfloatp - is this a float? */
  152. LVAL xfloatp()
  153. {
  154.     LVAL arg;
  155.     arg = xlgetarg();
  156.     xllastarg();
  157.     return (floatp(arg) ? true : NIL);
  158. }
  159.  
  160. /* xcharp - is this a character? */
  161. LVAL xcharp()
  162. {
  163.     LVAL arg;
  164.     arg = xlgetarg();
  165.     xllastarg();
  166.     return (charp(arg) ? true : NIL);
  167. }
  168.  
  169. /* xstringp - is this a string? */
  170. LVAL xstringp()
  171. {
  172.     LVAL arg;
  173.     arg = xlgetarg();
  174.     xllastarg();
  175.     return (stringp(arg) ? true : NIL);
  176. }
  177.  
  178. /* xarrayp - is this an array? */
  179. LVAL xarrayp()
  180. {
  181.     LVAL arg;
  182.     arg = xlgetarg();
  183.     xllastarg();
  184.     return (vectorp(arg) ? true : NIL);
  185. }
  186.  
  187. /* xstreamp - is this a stream? */
  188. LVAL xstreamp()
  189. {
  190.     LVAL arg;
  191.     arg = xlgetarg();
  192.     xllastarg();
  193.     return (streamp(arg) || ustreamp(arg) ? true : NIL);
  194. }
  195.  
  196. /* xobjectp - is this an object? */
  197. LVAL xobjectp()
  198. {
  199.     LVAL arg;
  200.     arg = xlgetarg();
  201.     xllastarg();
  202.     return (objectp(arg) ? true : NIL);
  203. }
  204.  
  205. /* xboundp - is this a value bound to this symbol? */
  206. LVAL xboundp()
  207. {
  208.     LVAL sym;
  209.     sym = xlgasymbol();
  210.     xllastarg();
  211.     return (boundp(sym) ? true : NIL);
  212. }
  213.  
  214. /* xfboundp - is this a functional value bound to this symbol? */
  215. LVAL xfboundp()
  216. {
  217.     LVAL sym;
  218.     sym = xlgasymbol();
  219.     xllastarg();
  220.     return (fboundp(sym) ? true : NIL);
  221. }
  222.  
  223. /* xnull - is this null? */
  224. LVAL xnull()
  225. {
  226.     LVAL arg;
  227.     arg = xlgetarg();
  228.     xllastarg();
  229.     return (null(arg) ? true : NIL);
  230. }
  231.  
  232. /* xlistp - is this a list? */
  233. LVAL xlistp()
  234. {
  235.     LVAL arg;
  236.     arg = xlgetarg();
  237.     xllastarg();
  238.     return (listp(arg) ? true : NIL);
  239. }
  240.  
  241. /* xendp - is this the end of a list? */
  242. LVAL xendp()
  243. {
  244.     LVAL arg;
  245.     arg = xlgalist();
  246.     xllastarg();
  247.     return (null(arg) ? true : NIL);
  248. }
  249.  
  250. /* xconsp - is this a cons? */
  251. LVAL xconsp()
  252. {
  253.     LVAL arg;
  254.     arg = xlgetarg();
  255.     xllastarg();
  256.     return (consp(arg) ? true : NIL);
  257. }
  258.  
  259. /* xeq - are these equal? */
  260. LVAL xeq()
  261. {
  262.     LVAL arg1,arg2;
  263.  
  264.     /* get the two arguments */
  265.     arg1 = xlgetarg();
  266.     arg2 = xlgetarg();
  267.     xllastarg();
  268.  
  269.     /* compare the arguments */
  270.     return (arg1 == arg2 ? true : NIL);
  271. }
  272.  
  273. /* xeql - are these equal? */
  274. LVAL xeql()
  275. {
  276.     LVAL arg1,arg2;
  277.  
  278.     /* get the two arguments */
  279.     arg1 = xlgetarg();
  280.     arg2 = xlgetarg();
  281.     xllastarg();
  282.  
  283.     /* compare the arguments */
  284.     return (eql(arg1,arg2) ? true : NIL);
  285. }
  286.  
  287. /* xequal - are these equal? (recursive) */
  288. LVAL xequal()
  289. {
  290.     LVAL arg1,arg2;
  291.  
  292.     /* get the two arguments */
  293.     arg1 = xlgetarg();
  294.     arg2 = xlgetarg();
  295.     xllastarg();
  296.  
  297.     /* compare the arguments */
  298.     return (equal(arg1,arg2) ? true : NIL);
  299. }
  300.  
  301. /* xset - built-in function set */
  302. LVAL xset()
  303. {
  304.     LVAL sym,val;
  305.  
  306.     /* get the symbol and new value */
  307.     sym = xlgasymbol();
  308.     val = xlgetarg();
  309.     xllastarg();
  310.  
  311.     /* assign the symbol the value of argument 2 and the return value */
  312.     setvalue(sym,val);
  313.  
  314.     /* return the result value */
  315.     return (val);
  316. }
  317.  
  318. /* xgensym - generate a symbol */
  319. LVAL xgensym()
  320. {
  321.     char sym[STRMAX+11]; /* enough space for prefix and number */
  322.     LVAL x;
  323.  
  324.     /* get the prefix or number */
  325.     if (moreargs()) {
  326.     x = xlgetarg();
  327.     switch (ntype(x)) {
  328.     case SYMBOL:
  329.         x = getpname(x);
  330.     case STRING:
  331.         strncpy(gsprefix,getstring(x),STRMAX);
  332.         gsprefix[STRMAX] = '\0';
  333.         break;
  334.     case FIXNUM:
  335.         gsnumber = getfixnum(x);
  336.         break;
  337.     default:
  338.         xlerror("bad argument type",x);
  339.     }
  340.     }
  341.     xllastarg();
  342.  
  343.     /* create the pname of the new symbol */
  344.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  345.  
  346.     /* make a symbol with this print name */
  347.     return (xlmakesym(sym));
  348. }
  349.  
  350. /* xmakesymbol - make a new uninterned symbol */
  351. LVAL xmakesymbol()
  352. {
  353.     return (makesymbol(FALSE));
  354. }
  355.  
  356. /* xintern - make a new interned symbol */
  357. LVAL xintern()
  358. {
  359.     return (makesymbol(TRUE));
  360. }
  361.  
  362. /* makesymbol - make a new symbol */
  363. LOCAL LVAL makesymbol(iflag)
  364.   int iflag;
  365. {
  366.     LVAL pname;
  367.  
  368.     /* get the print name of the symbol to intern */
  369.     pname = xlgastring();
  370.     xllastarg();
  371.  
  372.     /* make the symbol */
  373.     return (iflag ? xlenter(getstring(pname))
  374.               : xlmakesym(getstring(pname)));
  375. }
  376.  
  377. /* xsymname - get the print name of a symbol */
  378. LVAL xsymname()
  379. {
  380.     LVAL sym;
  381.  
  382.     /* get the symbol */
  383.     sym = xlgasymbol();
  384.     xllastarg();
  385.  
  386.     /* return the print name */
  387.     return (getpname(sym));
  388. }
  389.  
  390. /* xsymvalue - get the value of a symbol */
  391. LVAL xsymvalue()
  392. {
  393.     LVAL sym,val;
  394.  
  395.     /* get the symbol */
  396.     sym = xlgasymbol();
  397.     xllastarg();
  398.  
  399.     /* get the global value */
  400.     while ((val = getvalue(sym)) == s_unbound)
  401.     xlunbound(sym);
  402.  
  403.     /* return its value */
  404.     return (val);
  405. }
  406.  
  407. /* xsymfunction - get the functional value of a symbol */
  408. LVAL xsymfunction()
  409. {
  410.     LVAL sym,val;
  411.  
  412.     /* get the symbol */
  413.     sym = xlgasymbol();
  414.     x